home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / fintcmb / fontcomb.pas next >
Pascal/Delphi Source File  |  1996-04-08  |  5KB  |  181 lines
  1. { This component lists all the screen fonts on an owner draw combobox
  2.   with a small bitmap indicates whether the font is true type or not.
  3.   By Hardy Yau, CIS 102144,712. No Copyright. No Fee. No Guarantee. Enjoy!}
  4. (*  Special thanks to Xavier Pacheco for answering my questions. *)
  5.  
  6. unit Fontcomb;
  7.  
  8. interface
  9.  
  10. uses
  11.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  12.   Forms, Dialogs, StdCtrls, Menus;
  13.  
  14. type
  15.   TFontComboBox = class(TCustomComboBox)
  16.   private
  17.     { Private declarations }
  18.     FBitmap: TBitmap;
  19.     FCanvas: TControlCanvas;
  20.     function  IsTrueType(Index: Integer): Boolean;
  21.     procedure DrawTT(Background: TColor);
  22.   protected
  23.     { Protected declarations }
  24.     procedure CreateWnd; override;
  25.   public
  26.     { Public declarations }
  27.     constructor Create(AOwner: TComponent); override;
  28.     destructor  Destroy; override;
  29.     procedure   DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  30.   published
  31.     { Published declarations }
  32.     property Color;
  33.     property Ctl3D;
  34.     property DragMode;
  35.     property DragCursor;
  36.     property DropDownCount;
  37.     property Enabled;
  38.     property ParentColor;
  39.     property ParentCtl3D;
  40.     property ParentShowHint;
  41.     property PopupMenu;
  42.     property ShowHint;
  43.     property TabOrder;
  44.     property TabStop;
  45.     property Visible;
  46.     property OnChange;
  47.     property OnClick;
  48.     property OnDblClick;
  49.     property OnDragDrop;
  50.     property OnDragOver;
  51.     property OnDropDown;
  52.     property OnEndDrag;
  53.     property OnEnter;
  54.     property OnExit;
  55.     property OnKeyDown;
  56.     property OnKeyPress;
  57.     property OnKeyUp;
  58.   end;
  59.  
  60. procedure Register;
  61.  
  62. implementation
  63.  
  64. procedure Register;
  65. begin
  66.   RegisterComponents('Samples', [TFontComboBox]);
  67. end;
  68.  
  69. constructor TFontComboBox.Create(AOwner: TComponent);
  70. begin
  71.   inherited Create(AOwner);
  72.   Font.Name := 'MS Sans Serif';
  73.   Font.Size := 8;
  74.   Font.Style := Font.Style - [fsBold];
  75.   Sorted := True;
  76.   Style := csOwnerDrawFixed;
  77.   ItemHeight := 16;
  78.   {Create a bitmap for drawing}
  79.   FBitmap := TBitmap.Create;
  80.   FBitmap.Height := 12;
  81.   FBitmap.Width := 12;
  82.   {Create a Canvas for checking True Type property}
  83.   FCanvas := TControlCanvas.Create;
  84.   FCanvas.Control := Self;
  85. end;
  86.  
  87. destructor TFontComboBox.Destroy;
  88. begin
  89.   FBitmap.Free;
  90.   FCanvas.Free;
  91.   inherited Destroy;
  92. end;
  93.  
  94. procedure TFontComboBox.CreateWnd;
  95. begin
  96.   inherited CreateWnd;
  97.   Items.Assign(Screen.Fonts);
  98.   ItemIndex := 0;
  99. end;
  100.  
  101. procedure TFontComboBox.DrawItem(Index: Integer; Rect: TRect;
  102.   State: TOwnerDrawState);
  103. begin
  104.   { Rect.Left = 3 means drawing on the Static portion of the ComboBox }
  105.   with Canvas do begin
  106.     FillRect(Rect);
  107.     if IsTrueType(Index) and (Rect.Left <> 3) then begin
  108.        DrawTT(Brush.Color);
  109.        Draw(Rect.Left+2, Rect.Top+2, FBitmap);
  110.     end;
  111.     if (Rect.Left <> 3) then
  112.        TextOut(Rect.Left+16, Rect.Top, Items[Index])
  113.     else
  114.        TextOut(Rect.Left, Rect.Top, Items[Index])
  115.   end;
  116. end;
  117.  
  118. function TFontComboBox.IsTrueType(Index: Integer): Boolean;
  119. var
  120.   Metrics: TTextMetric;
  121.   lf: TLogFont;
  122.   oldFont, newFont: HFont;
  123. begin
  124.   with lf do begin
  125.     lfHeight := 10;
  126.     lfWidth := 10;
  127.     lfEscapement := 0;
  128.     lfWeight := FW_REGULAR;
  129.     lfItalic := 0;
  130.     lfUnderline := 0;
  131.     lfStrikeOut := 0;
  132.     lfCharSet := DEFAULT_CHARSET;
  133.     lfOutPrecision := OUT_DEFAULT_PRECIS;
  134.     lfClipPrecision := CLIP_DEFAULT_PRECIS;
  135.     lfQuality := DEFAULT_QUALITY;
  136.     lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
  137.     StrPCopy(lfFaceName, Items[Index]);
  138.   end;
  139.   newFont := CreateFontIndirect(lf);
  140.   oldFont := SelectObject(FCanvas.Handle, newFont);
  141.   GetTextMetrics(FCanvas.Handle, Metrics);
  142.   Result := (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) <> 0;
  143.   SelectObject(FCanvas.Handle, oldFont);
  144.   DeleteObject(newFont);
  145. end;
  146.  
  147. procedure TFontComboBox.DrawTT(Background: TColor);
  148.   procedure DrawT(OrgX, OrgY: Integer; Color: TColor);
  149.   begin
  150.    with FBitmap.Canvas do begin
  151.      Brush.Style := bsSolid;
  152.      Pen.Color := Color;
  153.      MoveTo(OrgX,OrgY);
  154.      LineTo(OrgX+7,OrgY);
  155.      LineTo(OrgX+7,OrgY+3);
  156.      MoveTo(OrgX,OrgY);
  157.      LineTo(OrgX,OrgY+3);
  158.      MoveTo(OrgX+1,OrgY);
  159.      LineTo(OrgX+1,OrgY+1);
  160.      MoveTo(OrgX+6,OrgY);
  161.      LineTo(OrgX+6,OrgY+1);
  162.      MoveTo(OrgX+3,OrgY);
  163.      LineTo(OrgX+3,OrgY+8);
  164.      MoveTo(OrgX+4,OrgY);
  165.      LineTo(OrgX+4,OrgY+8);
  166.      MoveTo(OrgX+1,OrgY+8);
  167.      LineTo(OrgX+6,OrgY+8);
  168.    end;
  169.   end;
  170. begin
  171.   with FBitmap.Canvas do begin
  172.     Brush.Style := bsClear;
  173.     Brush.Color := background;
  174.     FillRect(Rect(0,0,12,12));
  175.     DrawT(0,0,clGray);
  176.     DrawT(4,3,clBlack);
  177.   end;
  178. end;
  179.  
  180. end.
  181.